PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/tvmacro.exe/MACDEMO.PAS

Pascal/Delphi Source File | 1992-01-31 | 7.9 KB | 289 lines

{
  Very simple application to demonstrate Macros. Documented to show the
  modifications you will need to make to your application to implement
  macros.
}

Program MacDemo;

{$DEFINE MACROS}         {implement macros}

{$X+}

  {------------------------ Macros Modification ----------------------------}
  { Include Macros on your Uses line. (MacHelp is added for this demo).     }
  {-------------------------------------------------------------------------}
Uses Objects, Drivers, Views, Menus, App, HelpFile, MsgBox
{$IFDEF MACROS}
,Macros,
MacHelp
{$ENDIF}
;

const
   cmRecordMacro     = 1500;
   cmStopRecording   = 1501;
   cmPlaybackMacro   = 1502;
   cmDeleteMacro     = 1503;


Type

  {------------------------ Macros Modification ----------------------------}
  { MyApp is an object of type TMacApp instead of TApplication.             }
  {-------------------------------------------------------------------------}
  PMyApp = ^MyApp;
{$IFDEF MACROS}
  MyApp = Object(TMacApp)
{$ELSE}
  MyApp = Object(TApplication)
{$ENDIF}
    Constructor Init;
    Procedure InitStatusLine; Virtual;
    Procedure InitMenuBar; Virtual;
    Procedure HandleEvent(var Event: TEvent); Virtual;
{$IFDEF MACROS}
    Procedure GetEvent(var Event: TEvent); virtual;
{$ENDIF}
    function GetPalette: PPalette; virtual;
    Procedure NewWindow;
    Destructor Done; Virtual;
  End;

  PMyStatusLine = ^TMyStatusLine;
  TMyStatusLine = object(TStatusLine)
    function Hint(AHelpCtx: Word): String; virtual;
  end;

  PMyWindow = ^TMyWindow;
  TMyWindow = Object(TWindow)
     Constructor Init(Bounds: TRect; WinTitle: String; WindowNo: Word);
  End;

  PMyDeskTop = ^TMyDeskTop;
  TMyDeskTop = object(TDeskTop)
     Windw: PMyWindow;
  End;

Const
  cmNewWin   = 101;


function TMyStatusLine.Hint(AHelpCtx: Word): String;
var Mem : string;
begin
  str(MemAvail, Mem);
  Hint :=  Mem + ' free';
end;


{ ** MyApp **}
Constructor MyApp.Init;
Begin

  {------------------------ Macros Modification ----------------------------}
  { Call TMacApp.Init instead of TApplication.Init                          }
  {-------------------------------------------------------------------------}
{$IFDEF MACROS}
  TMacApp.Init;
{$ELSE}
  TApplication.Init;
{$ENDIF}
  RegisterHelpFile;
End;

Destructor MyApp.Done;
Begin

  {------------------------ Macros Modification ----------------------------}
  { Call TMacApp.Done instead of TApplication.Done                          }
  {-------------------------------------------------------------------------}
{$IFDEF MACROS}
  TMacApp.Done;
{$ELSE}
  TApplication.Done;
{$ENDIF}
End;

function MyApp.GetPalette: PPalette;
const
  CNewColor = CColor + CHelpColor;
  CNewBlackWhite = CBlackWhite + CHelpBlackWhite;
  CNewMonochrome = CMonochrome + CHelpMonochrome;
  P: array[apColor..apMonochrome] of string[Length(CNewColor)] =
    (CNewColor, CNewBlackWhite, CNewMonochrome);
begin
  GetPalette := @P[AppPalette];
end;

Procedure MyApp.InitMenuBar;
Var
  R: TRect;
Begin
  GetExtent(R);
  R.B.Y := R.A.Y + 1;
  MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('~F~ile', hcNoContext, NewMenu(
      NewItem('~N~ew', 'F4', kbF4, cmNewWin, hcNoContext,
      NewItem('~S~ize/Move', 'Ctrl-F5', kbCtrlF5, cmResize, 1051,
    nil))),


  {------------------------ Macros Modification ----------------------------}
  { Add code below to your application's menu.                              }
  {-------------------------------------------------------------------------}
{$IFDEF MACROS}
    NewSubMenu('~M~acros', {0}hcMacros, NewMenu(
      NewItem('~R~ecord', '', kbNoKey, cmRecordMacro, hcRecording,
      NewItem('~S~top Recording', '', kbNoKey, cmStopRecording, hcRecording,
      NewItem('~D~elete', '', kbNoKey, cmDeleteMacro, hcDeleting,
      NewItem('~P~layback', '', kbNoKey, cmPlaybackMacro, hcPlayback,
    nil))))),
{$ENDIF}


      NewLine(
        NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
      nil))))))
{$IFDEF MACROS}
      )
{$ENDIF}
      ;
End;

{$IFDEF MACROS}
procedure MyApp.GetEvent(var Event: TEvent);
var
  WH: PWindow;
  HFile: PHelpFile;
  HelpStrm: PDosStream;
const
  HelpInUse: Boolean = False;
begin

  {------------------------ Macros Modification ----------------------------}
  { Calls TMacApp.GetEvent instead of TApplication.GetEvent.                }
  { This change is required only if your application overrides GetEvent to  }
  { implement context-sensitive help (as done in TVDEMO.PAS).               }
  {-------------------------------------------------------------------------}
  TMacApp.GetEvent(Event);
  {TApplication.GetEvent(Event);}

  case Event.What of
    evCommand:
      if (Event.Command = cmHelp) and not HelpInUse then
      begin
        HelpInUse := True;

  {------------------------ Macros Modification ----------------------------}
  { The name of the Macros Help file is here, instead of your help file, in }
  { order to supply help for this demo.                                     }
  {-------------------------------------------------------------------------}
        HelpStrm := New(PDosStream, Init('MACHELP.HLP', stOpenRead));

        HFile := New(PHelpFile, Init(HelpStrm));
        if HelpStrm^.Status <> stOk then
        begin
          MessageBox('Could not open help file.', nil, mfError + mfOkButton);
          Dispose(HFile, Done);
        end
        else
        begin
          WH := New(PHelpWindow,Init(HFile, GetHelpCtx));
          if ValidView(WH) <> nil then
          begin
            ExecView(WH);
            Dispose(WH, Done);
          end;
          ClearEvent(Event);
        end;
        HelpInUse := False;
      end;
    evMouseDown:
      if Event.Buttons <> 1 then Event.What := evNothing;
  end;
end;
{$ENDIF}


Procedure MyApp.InitStatusLine;
Var
  R: TRect;
Begin
  GetExtent(R);
  R.A.Y := R.B.Y - 1;
  StatusLine := New(PMyStatusLine, Init(R,
  NewStatusDef(0, $FFFF,
    NewStatusKey('~F1~ Help', kbF1, cmHelp,
    NewStatusKey('', kbF10, cmMenu,
    NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
    NewStatusKey('~F4~ New', kbF4, cmNewWin,
    NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
    nil))))),
  nil)));
End;

Procedure MyApp.HandleEvent(var Event: TEvent);
Begin
  TApplication.HandleEvent(Event);
  if Event.What = evCommand then
    Begin
      Case Event.Command of
        cmNewWin: NewWindow;


  {------------------------ Macros Modification ----------------------------}
  { Add code block below to your application's event handler.               }
  {-------------------------------------------------------------------------}
{$IFDEF MACROS}
        cmRecordMacro   : StartRecording;
        cmStopRecording : begin
                            StopRecording;

                            ClearEvent (Event);     { ********************* }
                            PutEvent (Event);       { Clears event queue.   }
                                                    { Required for macros   }
                                                    { that playback other   }
                                                    { macros.               }
                          end;
        cmPlaybackMacro : StartPlayback;
        cmDeleteMacro   : DeleteMacro;
{$ENDIF}


      else
        Exit;
      End;
      ClearEvent(Event);
    End;
End;

Procedure MyApp.NewWindow;
Var
  Window:PMyWindow;
  R: TRect;
Begin
  R.Assign(0, 0, 24, 7);
  R.Move(Random(55), Random(16));
  Window := New(PMyWindow, Init(R, 'Demo Window', 1));
  DeskTop^.Insert(Window);
End;

{ ** MyDeskTop **}

{ ** MyWindow **}
Constructor TMyWindow.Init(Bounds: TRect; WinTitle: String; WindowNo: Word);
Begin
  TWindow.init(Bounds,WinTitle,WindowNo);
End;

{ Main Program }
Var
  MyTApp:MyApp;

Begin
  MyTApp.Init;
  MyTApp.Run;
  MyTApp.Done;
End.